home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 9.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  18KB  |  637 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "hdr.h"
  10. #include "vars.h"
  11. #include "setp.h"
  12. #include "errmsgp.h"
  13. #include "miscp.h"
  14. #include "smiscp.h"
  15. #include "nodesp.h"
  16. #include "dclmapp.h"
  17. #include "chapp.h"
  18.  
  19. void task_spec(Node task_node)                                /*;task_spec*/
  20. {
  21.     Node    entries_node, id_node;
  22.     int        anon;
  23.     Symbol    task_type_name, t_name, old_kind, entry_sym;
  24.     char    *id;
  25.     Declaredmap    entry_list;
  26.     Fordeclared fd1;
  27.  
  28.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  task_spec");
  29.  
  30.     id_node = N_AST1(task_node);
  31.     entries_node = N_AST2(task_node);
  32. #ifdef TBSN
  33.     /* ignore opt_specs_node for now, as N_AST3 used for N_TYPE
  34.      * DS  9-22-86
  35.      */
  36.     opt_specs_node = N_AST3(task_node);
  37. #endif
  38.     /*
  39.      * If this is a task declaration, an anonymous task type is introduced
  40.      * for it. Entry declarations are always attached to the task type.
  41.      * TBSL : processing of specifications.
  42.      */
  43.     anon = (N_KIND(task_node) == as_task_spec);
  44.     id = N_VAL(id_node);
  45.     if (anon)
  46.         task_type_name =
  47.            find_new(strjoin(strjoin("task_type:", id), newat_str()));
  48.     else
  49.         task_type_name = find_type_name(id_node);
  50.  
  51.     if (task_type_name == symbol_any) return; /* Illegal redeclaration. */
  52.  
  53.     if (anon) {
  54. #ifdef TBSN
  55.         XREF lessf:= task_type_name;
  56. #endif
  57.     }
  58.     old_kind = TYPE_OF(task_type_name); /* may have been private */
  59.  
  60.     NATURE(task_type_name) = na_task_type_spec;
  61.     TYPE_OF(task_type_name) = task_type_name;
  62.     SIGNATURE(task_type_name) = tup_new(0);  /* created by the expander */
  63.     root_type(task_type_name) = task_type_name;
  64.     initialize_representation_info(task_type_name, TAG_TASK);
  65.     /* priv_types is {private, limited_private}; first arg to check_priv_decl
  66.      * is one of MISC_TYPE_ATTRIBUTES ...
  67.      */
  68.     if (old_kind == symbol_private)
  69.         check_priv_decl(TA_PRIVATE, task_type_name);
  70.     else if (old_kind == symbol_limited_private)
  71.         check_priv_decl(TA_LIMITED_PRIVATE, task_type_name);
  72.     if (anon) {
  73.         t_name = find_new(id);
  74.         NATURE(t_name) = na_task_obj_spec;
  75.         TYPE_OF(t_name) = task_type_name;
  76.         SIGNATURE(t_name) = (Tuple) 0;
  77.         N_UNQ(task_node) = t_name;
  78.     }
  79.  
  80.     N_TYPE(task_node) = task_type_name;
  81.     newscope(task_type_name);    /* introduce new scope */
  82. #ifdef TBSN
  83.     prefix := prefix + id + '.';            $ For unique names.
  84. #endif
  85.         sem_list(entries_node);
  86. #ifdef TBSN
  87.     /* ignore opt_specs_node for now, as N_AST3 used for N_TYPE
  88.      * DS  9-22-86
  89.      */
  90.     sem_list(opt_specs_node);
  91. #endif
  92.  
  93.     entry_list = DECLARED(scope_name);
  94.     popscope();
  95.  
  96.     if (anon) {
  97.         /* Attach entry declarations for task object as well, and emit a
  98.          * declaration for the task object itself.
  99.          */
  100.         SIGNATURE(t_name) = (Tuple) 0;
  101.         DECLARED(t_name) = entry_list;
  102.  
  103.         FORDECLARED(id, entry_sym, entry_list, fd1)
  104.             /*(for entry = entry_list(id))*/
  105.             SCOPE_OF(entry_sym) = t_name;
  106.         ENDFORDECLARED(fd1)
  107.     }
  108.     return;
  109. }
  110.  
  111. void accept_statement(Node accept_node)                    /*;accept_statement*/
  112. {
  113.  
  114.     /* This procedure opens a new scope when an ACCEPT statement is seen.
  115.      * In the case of an overloaded entry name, it selects the one with
  116.      * the matching signature.
  117.      */
  118.  
  119.     int        certain;
  120.     Symbol    task_name, task_type, real_name, entry_name, ix_t;
  121.     Set        entries;
  122.     Tuple    formals;
  123.     Forset    fs1;
  124.     Node    id_node, indx, body_node;
  125.     Node    formals_node;
  126.     int        exists, nat;
  127.     char    *id, *junk;
  128.     Fortup    ft1;
  129.  
  130.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : accept_statement");
  131.  
  132.     id_node = N_AST1(accept_node);
  133.     indx = N_AST2(accept_node);
  134.     formals_node = N_AST3(accept_node);
  135.     body_node = N_AST4(accept_node);
  136.  
  137.     id = N_VAL(id_node);
  138.     formals = get_formals(formals_node, id);
  139.     /* Find the task  in which the accept statement occurs. The accept
  140.      * may of course appear within a block or another accept statement.
  141.      */
  142.  
  143.     exists    = FALSE;
  144.     FORTUP(task_name = (Symbol), open_scopes, ft1);
  145.         nat = NATURE(task_name);
  146.         if( nat != na_block && nat != na_entry && nat != na_entry_family) {
  147.             exists = TRUE;
  148.             break;
  149.         }
  150.     ENDFORTUP(ft1);
  151.     certain = exists;
  152.     task_type = TYPE_OF(task_name);
  153.  
  154.     if (task_type == (Symbol)0 || NATURE(task_type) != na_task_type)  {
  155.         errmsg("Accept statements can only appear in tasks","9.5", accept_node);
  156.         /* following junk line in SETL not needed here    ds 1 nov 84
  157.          * entry_name = id;
  158.          */
  159.         return;
  160.     }
  161.  
  162.     real_name = entry_name = dcl_get(DECLARED(task_name), id);
  163.  
  164.     if (entry_name == (Symbol)0) {
  165.         errmsg("Undefined entry name in ACCEPT ", "9.5", id_node);
  166. #ifdef TBSL
  167.         -- entry_name is symbol, id is string        ds 2-jan-85
  168.             entry_name = id; /* For dummy scope. */
  169. #endif
  170.         return; /* to Initialize it . */
  171.     }
  172.     else if (NATURE(entry_name) == na_entry) {
  173.         /* Collect all its overloadings and select the one with the
  174.          * correct signature.
  175.          */
  176.         entries = OVERLOADS(entry_name);
  177.  
  178.         if (indx != OPT_NODE) {
  179.             errmsg("invalid index on entry (not entry family)", "9.5", indx);
  180.         }
  181.  
  182.         exists = FALSE;
  183.         FORSET(entry_name = (Symbol), entries, fs1);
  184.             if (same_sig_spec(entry_name, formals)) {
  185.                 exists = TRUE;
  186.                 break;
  187.             }
  188.         ENDFORSET(fs1);
  189.         if (!exists) {
  190.             errmsg("Entry name in ACCEPT statement does not match any entry" ,
  191.               "9.5", id_node);
  192.             return;
  193.         }
  194.     }
  195.     else if (NATURE(entry_name) == na_entry_family) {
  196.         ix_t = (Symbol) index_type(TYPE_OF(entry_name));
  197.  
  198.         if (indx == OPT_NODE) {
  199.             errmsg("Missing index for entry family.", "9.5", accept_node);
  200.         }
  201.         else {
  202.             adasem(indx);
  203.             check_type(ix_t, indx);
  204.         }    
  205.     }
  206.     else {
  207.         errmsg("Invalid entry name in ACCEPT", "9.5", id_node);
  208.         return;
  209.     }
  210.  
  211.     N_UNQ(id_node) = entry_name;
  212.     TO_XREF(entry_name);
  213.  
  214.     reprocess_formals(entry_name, formals_node);
  215.     if (in_open_scopes(entry_name )) {
  216.         errmsg_l("An accept_statement cannot appear within an ACCEPT for",
  217.           " the same entry", "9.5", accept_node);
  218.     }
  219.     newscope(entry_name);
  220.     has_return_stk = tup_with(has_return_stk, (char *)FALSE);
  221.     adasem(body_node);
  222.     junk = tup_frome(has_return_stk);
  223.     popscope();
  224. }
  225.  
  226. void entry_decl(Node entry_node)                            /*;entry_decl*/
  227. {
  228.     /* An entry declaration is treated like a procedure specification.
  229.      * An anonymous type is created for the entry object. This type is
  230.      * used by the interpreter to build the environment of an entry.
  231.      */
  232.  
  233.     Symbol    entry_sym, entry_type;
  234.     Node    id_node, formal_list;
  235.     Tuple    formals;
  236.  
  237.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  entry_decl");
  238.  
  239.     id_node = N_AST1(entry_node);
  240.     formal_list = N_AST2(entry_node);
  241.  
  242.     formals = get_formals(formal_list, N_VAL(id_node));
  243.  
  244.     check_out_parameters(formals);
  245.  
  246.     /*entry = chain_overloads(N_VAL(id_node), [na_entry, 'none', formals]); */
  247.     entry_sym = chain_overloads(N_VAL(id_node), na_entry, symbol_none,
  248.       formals, (Symbol)0, formal_list);
  249.  
  250.     entry_type = anonymous_type();
  251.  
  252.     /*SYMBTAB(entry_type) := [na_entry_former, scope_name, signature(entry)]; */
  253.     NATURE(entry_type) = na_entry_former;
  254.     TYPE_OF(entry_type) = scope_name;
  255.     SIGNATURE(entry_type) = SIGNATURE(entry_sym);
  256.     root_type(entry_type) = entry_type;
  257.  
  258.     N_UNQ(id_node)    = entry_sym;
  259.     N_TYPE(entry_node) = entry_type;
  260. }
  261.  
  262. void entry_family_decl(Node entry_node)                    /*;entry_family_decl*/
  263. {
  264.     /* An entry family  is not  an overloadable  object. It     is  constructed
  265.      * as an array of entries. An anonymous type is introduced for the entry
  266.      * former, just     as for an  entry declaration, and another is introduced
  267.      * for the array representing the family.
  268.      */
  269.  
  270.     Symbol    entry_sym, entry_type, family_type;
  271.     Symbol    opt_range;
  272.     Tuple    formals, f, tup;
  273.     Node    id_node, discrete_range, formal_list;
  274.  
  275.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : entry_family_decl");
  276.  
  277.     id_node = N_AST1(entry_node);
  278.     discrete_range = N_AST2(entry_node);
  279.     formal_list = N_AST3(entry_node);
  280.  
  281.     entry_sym = find_new(N_VAL(id_node));
  282.  
  283.     formals = get_formals(formal_list, N_VAL(id_node));
  284.  
  285.     check_out_parameters(formals);
  286.  
  287.     f = process_formals(entry_sym, formals, TRUE);
  288.  
  289.     entry_type = anonymous_type();
  290.  
  291.     NATURE(entry_type) = na_entry_former;
  292.     TYPE_OF(entry_type) = scope_name;
  293.     SIGNATURE(entry_type) = f;
  294.     root_type(entry_type) = entry_type;
  295.     adasem(discrete_range);
  296.     opt_range = make_index(discrete_range);
  297.     family_type = anonymous_type();
  298.     /* SYMBTAB(family_type) =
  299.      *        [na_array, family_type, [[opt_range], entry_type]];
  300.      */
  301.     NATUR